home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / PROLOG / HUMBOLT / HUMBOLTS / _files / _humboltsr / USER._c < prev    next >
Text File  |  1990-06-10  |  6KB  |  254 lines
  1. /***************************************************
  2. ****************************************************
  3. **                                                **
  4. **  HU-Prolog     Portable Interpreter System     **
  5. **                                                **
  6. **  Release 1.61  September 1989                  **
  7. **                                                **
  8. **  Authors:      C.Horn, M.Dziadzka, M.Horn      **
  9. **                                                **
  10. **  (C) 1989      Humboldt-University             **
  11. **                Department of Mathematics       **
  12. **                GDR 1086 Berlin, P.O.Box 1297   **
  13. **                                                **
  14. ****************************************************
  15. ***************************************************/
  16.  
  17. #include "systems.h"
  18. #include "types.h"
  19. #include "atoms.h"
  20. #include "errors.h"
  21.  
  22. #if USER
  23.  
  24. IMPORT TERM A0,A1,A2;                /* from evalpred.c */
  25. IMPORT void InitUAtom();            /* from atomtabl.c */
  26. IMPORT int BCT;
  27. IMPORT TERM GLOTOP;
  28. IMPORT ENV E,CHOICEPOINT;
  29. IMPORT void ARGERROR(),ERROR();
  30. IMPORT boolean INTRES();
  31. IMPORT boolean isatom(),appears();
  32. IMPORT void STARTATOM(),ATOMCHAR();
  33. IMPORT string NEWATOM;
  34. IMPORT void TESTATOM();
  35.  
  36. /*
  37. EXPORT boolean CallUser();            only used in evalpred.c 
  38. EXPORT void InitUser();               only used in prolog.c 
  39. */
  40.  
  41. #define useratom(i)        (LAST_ATOM + atom_units(i))
  42.  
  43. /* used by auster */
  44.  
  45. static boolean DOLENGTH(void)
  46. { int i=0; TERM T;
  47.   T=A1;
  48.   while(name(T)==CONS_2)
  49.     {i++; T=arg2(T); }
  50.   TESTATOM(NIL_0,T);
  51.   return INTRES(A0,i);
  52. }
  53.  
  54. #if SYMBOLARITH
  55. static boolean DOAPPEARS(void)
  56. {
  57.   if (!isatom(A0)) ARGERROR();
  58.   return appears(name(A0),1,A1);
  59. }
  60. #endif
  61.  
  62. boolean static DONTH(void)
  63. {
  64.   TERM Y;
  65.   int N;
  66.   if (name(A1)==INTT) N=ival(A1); else N=INTVALUE(A1);
  67.   if (N<=0) return false;
  68.   Y=A2;
  69.   while (--N>=1 && name(Y)==CONS_2) Y=arg2(Y); 
  70.   if (name(Y)==CONS_2) return UNI(A0,son(Y)); else return false;
  71. }
  72.  
  73. static boolean DOEXTEND(void)
  74. { TERM X,Y;
  75.   STRING S;
  76.   int C;
  77.   if(!isatom(A0)) return false;
  78.   STARTATOM();
  79.   S=longstring(name(A0));
  80.   while(C=repchar(S++)) ATOMCHAR(C);
  81.   X=A1;
  82.   while(name(X)==CONS_2)
  83.   { Y=arg1(X);
  84.     if (name(Y)==INTT) C=ival(Y);
  85.     else C=INTVALUE(Y);
  86.     if(C <=0 || C > 255) ARGERROR();
  87.     ATOMCHAR(C);
  88.     X=arg2(X);
  89.   }
  90.   TESTATOM(NIL_0,X);
  91.   ATOMCHAR(0);
  92.   return UNI(A2,mkatom(LOOKUP(NEWATOM,0,false)));
  93. }
  94.  
  95. static boolean DONAMELGT(void)
  96. { register int I; 
  97.   register STRING S;
  98.   if(!isatom(A1)) ARGERROR();
  99.   S=longstring(name(A1)); I=0;
  100.   while(repchar(S++)) I++;
  101.   return INTRES(A0,I);
  102. }
  103.  
  104. static boolean DOIDENTIFIER(void)
  105. { register STRING S;
  106.   register char ch;
  107.   if(!isatom(A0)) return false;
  108.   S=longstring(name(A0));
  109.   ch= repchar(S);
  110.   if (ch<'a' || ch>'z') return false;
  111.   while (ch = repchar(S++)) 
  112.   { if ('a'<=ch && ch <='z') continue;
  113.     if (ch=='_') continue;
  114.     if ('0'<=ch || ch<='9') continue;
  115.     return false;
  116.   }
  117.   return true;
  118. }
  119.  
  120. static int termlgt(TERM T)
  121. { register int I; 
  122.   deref(T);
  123.   if(name(T)>NORMATOM) 
  124.   { if(name(T)==CONS_2) 
  125.       { I= -2;
  126.     if(name(arg2(T))==NIL_0) I-=2;
  127.       }
  128.     else { STRING S;
  129.        S=longstring(name(T)); I=0;
  130.             while(repchar(S++)) I++;
  131.          }
  132.     { int N;
  133.       for(N=arity(name(T)),T=son(T);--N>=0;next_br(T))
  134.     I+=termlgt(T)+2;  
  135.     }
  136.   }
  137.   else if(name(T)==UNBOUNDT) I=3; 
  138.   else if(name(T)==INTT)
  139.        { int S;
  140.          I=1; S=ival(T); 
  141.          if(S<0) {++I; S= -S;}
  142.          while(S>=10) {++I; S=S/10;} 
  143.        }
  144. #if LONGARITH
  145.   else if(name(T)==LONGT)
  146.        { LONG S;
  147.          I=1; S=longval(T); 
  148.          if(S<0l) {++I; S= -S;}
  149.          while(S>=10l) {++I; S=S/10l;} 
  150.        }
  151. #endif
  152.   return I;
  153. }
  154.  
  155. static int termsize(TERM T)
  156. { register int I,N; 
  157.   deref(T);
  158.   I=1;
  159.   if(name(T)>NORMATOM) 
  160.     for(N=arity(name(T)),T=son(T);--N>=0;next_br(T)) I+=termsize(T);  
  161.   return I;
  162. }
  163.  
  164. static boolean DOGENINT(void)
  165. { 
  166.   return INTRES(A0,BCT++);
  167. }
  168.  
  169. static boolean DOGENVAR(void)
  170. { string S;
  171.   int I;
  172.   static char VARNAME[12];
  173.   S=itoa(BCT++);
  174.   I=1; 
  175.   VARNAME[0]='v';
  176.   while(VARNAME[I++]=*S++);
  177.   return UNI(A0,mkatom(LOOKUP(VARNAME,0,false)));
  178. }
  179.  
  180. LOCAL boolean DOGENFREEVAR(void)
  181. { register TERM T;
  182.   register TERM TT;
  183.   register ATOM A;
  184.   string S;
  185.   int I,N;
  186.   static char VARNAME[12];
  187.   N=0;
  188. newvar:
  189.   S=itoa(N++);
  190.   VARNAME[0]='v';
  191.   I=1;
  192.   while(VARNAME[I++]=*S++);
  193.   A=LOOKUP(VARNAME,0,false);
  194.   T=A1;
  195.   while (name(T)==CONS_2)
  196.   { 
  197.     TT=son(T); deref(TT);
  198.     if (name(TT)==COLON_2) 
  199.     { TT=son(TT); deref(TT);
  200.       if (name(TT)==A) goto newvar;
  201.     }
  202.     T=br(son(T));
  203.     deref(T);
  204.   }
  205.   return UNI(A0,mkatom(A));
  206. }
  207.  
  208.  
  209. void InitUser(int Phase)
  210. {
  211. InitUAtom(Phase,useratom(0),"$length",EVALP,NONO,2,false);
  212. InitUAtom(Phase,useratom(1),"genint",BTEVALP,NONO,1,false);
  213. InitUAtom(Phase,useratom(2),"namelgt",EVALP,NONO,2,false);
  214. InitUAtom(Phase,useratom(3),"termlgt",EVALP,NONO,2,false);
  215. InitUAtom(Phase,useratom(4),"termsize",EVALP,NONO,2,false);
  216. InitUAtom(Phase,useratom(5),"identifier",EVALP,NONO,1,false);
  217. InitUAtom(Phase,useratom(6),"genvar",BTEVALP,NONO,1,false);
  218. InitUAtom(Phase,useratom(7),"genfreevar",EVALP,NONO,2,false);
  219. #if SYMBOLARITH
  220. InitUAtom(Phase,useratom(8),"appears",EVALP,NONO,2,false);
  221. #endif
  222. InitUAtom(Phase,useratom(9),"extend_name",EVALP,NONO,3,false);
  223. InitUAtom(Phase,useratom(10),"n_th",EVALP,NONO,3,false);
  224. }
  225.  
  226. boolean CallUser(TERM X)
  227. { boolean res=false;
  228.     switch(name(X))
  229.     {
  230.      case useratom(0):res=DOLENGTH();break;
  231.      case useratom(1):res=DOGENINT();break;
  232.      case useratom(2):res=DONAMELGT();break;
  233.      case useratom(3):res=INTRES(A0,termlgt(A1));break;
  234.      case useratom(4):res=INTRES(A0,termsize(A1));break;
  235.      case useratom(5):res=DOIDENTIFIER(); break;
  236.      case useratom(6):res=DOGENVAR(); break;
  237.      case useratom(7):res=DOGENFREEVAR(); break;
  238. #if SYMBOLARITH
  239.      case useratom(8):res=DOAPPEARS(); break;
  240. #endif
  241.      case useratom(9):res=DOEXTEND(); break;
  242.      case useratom(10):res=DONTH(); break;
  243.      default:
  244.           ws("\007sorry, but this predicate is reserved, ");
  245.           ws("but not implemented yet\n");
  246.           ERROR(CALLE);
  247.     }
  248.   return res;
  249. }
  250.  
  251. #endif
  252.  
  253.  
  254.